Code and Notes (Week 5 Thursday)

module Prac where

import Data.Maybe
import Test.QuickCheck
import Data.List(sort, nub)

{-
            T
      'h' /   \ 'j'
        F      T
   'i' /  \ 'e'
      T    F
't'  /      \ 'l'
    T         F
              \ 'l'
               T
                \ 'o'
                 T

""
"j"
"hi"
"hit"
"hell"
"hello"

after "badly" deleting hello:

            T
      'h' /   \ 'j'
        F      T
   'i' /  \ 'e'
      T    F
't'  /      \ 'l'
    T         F
              \ 'l'
               T
                \ 'o'
                 T
-}

toList :: Trie -> [String]
toList (Trie b ts) =
  first ++ rest where
  first | b         = [""]
        | otherwise = []
  rest = concatMap (\(x,t) -> map (x:) $ toList t) ts

x :: Trie
x = Trie True [('h', Trie False [('i', Trie True [('t', Trie True [])]), ('e', Trie False [('l', Trie False [('l', Trie True [('o', Trie True [])])])])]), ('j', Trie True [])]

data Trie = Trie Bool [(Char,Trie)]
  deriving (Eq,Show)


{- using mapMaybe -}

deleteM :: String -> Trie -> Trie
deleteM "" (Trie b ts) = Trie False ts
deleteM (c:cs) (Trie b ts)
  = Trie b $ mapMaybe (\(c', t) -> 
      if c'==c
    then case deleteM cs t of
         (Trie False []) -> Nothing
         dt -> Just (c', dt)
    else Just (c', t)
    ) ts

delete :: String -> Trie -> Trie
delete "" (Trie b ts) = Trie False ts
delete (c:cs) (Trie b ts)
  = Trie b $ mapMaybe (\(c', t) -> 
      if c'==c
    then (if delete cs t == Trie False []
        then Nothing 
        else Just (c', delete cs t))
    else Just (c', t)
    ) ts


size :: Trie -> Int
size (Trie b ts) = countThis b + sum (map (size.snd) ts)
  where
    countThis True = 1
    countThis False = 0

{-
  Properties of 'delete':

  NOT an involution.

  'insert' is NOT left or right inverse of 'delete'.
  delete s (insert s t) == t -- not always true
  insert s (delete s t) == t -- not alwyas true

  it IS idempotent.
  delete s (delete s t) == delete s t
 -}

genTrie :: Int -> Gen Trie
genTrie 0 = pure $ Trie True []
genTrie n =
  Trie <$> arbitrary <*> (genKeys >>= genSubtries) where
  genKeys :: Gen [Char]
  genKeys = sort . nub <$> (resize 5 . listOf $ elements ['a'..'z'])
  genSubtries :: [Char] -> Gen [(Char,Trie)]
  genSubtries cs =
      zip cs <$> vectorOf (length cs) (genTrie . max 0 $ n-1-length cs)

instance Arbitrary Trie where
  arbitrary = sized $ genTrie . min 15
  shrink (Trie b ts) =
    (Trie b <$> shrinkList (const []) ts) ++
    (Trie b <$> map shrink ts)


{- `single xs` represents a dictionary consisting of only `xs`. -}
single :: String -> Trie
single []     = Trie True []
single (x:xs) = Trie False [(x,single xs)]

{- `insert t xs` inserts the word xs into the dictionary t. -}
insert :: String -> Trie -> Trie
insert [] (Trie _ ts)     = Trie True ts
insert (x:xs) (Trie b ts) =
  case span ((<x) . fst) ts of
    (ts1,[]) -> Trie b $ ts1 ++ [(x,single xs)]
    (ts1,(y,t):ts2)
      | x == y    -> Trie b $ ts1 ++ (x,insert xs t):ts2
      | otherwise -> Trie b $ ts1 ++ (x,single xs):(y,t):ts2




-- some tests for the properties

propInvolution :: String -> Trie -> Bool
propInvolution s t = delete s (delete s t) == t

propInsertRightInverse :: String -> Trie -> Bool
propInsertRightInverse s t = delete s (insert s t) == t

propInsertLeftInverse :: String -> Trie -> Bool
propInsertLeftInverse s t = insert s (delete s t) == t

propIdempotent :: String -> Trie -> Bool
propIdempotent s t = delete s (delete s t) == delete s t

-- check t s == False ==> delete s t == t







-- ADT stuff

{-
            4
          /   \
         1     11
        / \    / \
       L   L  15   L
-} 


-- module SearchTree(SearchTree, wellFormed) where

data SearchTree a = Leaf | Node a (SearchTree a) (SearchTree a)
  deriving (Eq,Show)

stAll :: (a -> Bool) -> SearchTree a -> Bool
stAll _ Leaf = True
stAll f (Node a t1 t2) = f a && stAll f t1 && stAll f t2

wellFormed :: Ord a => SearchTree a -> Bool
wellFormed Leaf = True
wellFormed (Node x t1 t2) = all id [stAll (<x) t1
                                  , stAll (>x) t2
                                  , wellFormed t1
                                  , wellFormed t2]

empty :: SearchTree a
empty = Leaf



-- Faustian stuff

--
-- length (faustianMap f xs) == length xs
-- faustianMap (f . g) xs == faustianMap f (faustianMap g xs)

faustianMap :: (a -> b) -> [a] -> [b]
faustianMap f [] = []
faustianMap f (a:as) = f a : replicate (length as) (f a)

sillyProp :: [a] -> Bool
sillyProp as = length as < 100

-- a new property approaches!
-- faustianMap id xs == xs

faustianMap' :: (a -> a) -> [a] -> [a]
faustianMap' _ as = as